open Types

module type IINTERPRETER =
sig
	val eval: (Types.instr Types.mpair * Types.stackel Types.mpair ref) -> Types.stackel
	exception Eval_Exception of string
end;;

module INTERPRETER : IINTERPRETER =
struct
	exception Eval_Exception of string
	
	(* LISTE DI OPERATORI *)
	let opArit = [("+", (+)); ("-", (-)); ("*", ( * )); ("/", (/)); ("%", (mod));]
	let opCompare = [("==", (=)); ("!=", (!=)); ("<", (<)); (">", (>)); (">=", (>=)); ("<=", (<=));]
	let opBool = [("&&", (&&)); ("||", (||));]
	let iBfun = [("square", (fun x -> x * x)); ("cube", (fun x -> x * x * x)); ("abs", (abs));]
	let bBfun = [("not", (not));]
	
	(* APPLICAZIONE DEGLI OPERATORI BINARI E UNARI *)
	let iEvalBfun2(op, v1, v2) = try Types.Int ((List.assoc op (opArit)) v1 v2) with Not_found -> (try Types.Bool ((List.assoc op (opCompare)) v1 v2) with Not_found -> raise (Eval_Exception "Errore iEvalBfun2"))
	let bEvalBfun2(op, v1, v2) = try Types.Bool ((List.assoc op (opBool)) v1 v2) with Not_found -> (try Types.Bool ((List.assoc op (opCompare)) v1 v2) with Not_found -> raise (Eval_Exception "Errore bEvalBfun2"))
	
	let iEvalBfun(f, v) = try Types.Int ((List.assoc f (iBfun)) v) with Not_found -> raise (Eval_Exception "Errore iEvalBfun")
	let bEvalBfun(f, v) = try Types.Bool ((List.assoc f (bBfun)) v) with Not_found -> raise (Eval_Exception "Errore bEvalBfun")
	let lEvalBfun(f, l) = (match l with Types.Cons(e1, e2) ->
								(match f with "hd" -> e1
											 |"tl" -> e2
											 |"isnull" -> Types.Bool false
											 | _ -> raise (Eval_Exception "Errore lEvalBfun")
						  		)
			| _ -> raise (Eval_Exception "Errore lEvalBfun")
		)
	
	(* FUNZIONI AUSILIARIE INTERPRETE *)
	(* restituzione dell'environment dal dump d *)
	let getEnv d = match !d with Types.MCons((e, pc), d1) -> e
		| _ -> raise (Eval_Exception "Errore getEnv")
	
	(* restituzione del program counter dal dump d *)
	let getPC d = match !d with Types.MCons((e, pc), d1) -> pc
		| _ -> raise (Eval_Exception "Errore getPC")
	
	(* restituzione del dump dal dump d *)
	let getDump d = match !d with Types.MCons((e, pc), d1) -> d1
		| _ -> raise (Eval_Exception "Errore getDump")
	
	(* restituzione della variabile alla posizione pos nell'environment env *)
	let rec getVar(env, pos) = match !env with
			Types.MNil -> raise (Eval_Exception "Errore getVar")
		| Types.MCons(var, next) -> if pos = 0 then var else getVar(next, pos - 1)
	
	(* aggiunta della variabile v nell'environment env *)
	let rec addEnv(v, env) = let r = !env in r := Types.MCons(v, ref (!(!env)))
	
	(* FUNZIONI DI DEBUG *)
(*	let rec toString stack = match stack with
			Types.Int x -> print_string(string_of_int(x)^"\n")
		| Types.Bool x -> print_string(string_of_bool(x)^"\n")
		| Types.Bfun x -> print_string("bfun"^x^"\n")
		| Types.Clos x -> print_string("clos\n")
		| Types.Cons (e1, e2) -> (print_string("cons("); toString e1 ; toString e2 ; print_string (")"))
		| Types.StackRef x -> (print_string("ref "); toString !x)
		| Types.Sus _ -> print_string("sus\n")
		| Types.StackNull -> print_string("null\n") 
		
	let rec envToString env = match env with
			Types.MNil -> print_string "fine\n"
		| Types.MCons(x, r) -> toString x; envToString !r
		*)
	
	(* FUNZIONE DI STAMPA DEL CODICE COMPILATO DI UN PROGRAMMA instr *)
	let rec programToString instr tab = match instr with
			Types.MNil -> print_string ""
		| Types.MCons(Types.End, next) -> print_string (tab^"End\n"); programToString !next tab
		| Types.MCons(Types.Exit, next) -> print_string (tab^"Exit\n"); programToString !next tab
		| Types.MCons(Types.Store, next) -> print_string (tab^"Store\n"); programToString !next tab
		| Types.MCons(Types.ILdbv v, next) -> print_string ((tab^"ILdbv "^(string_of_int v)^"\n")); programToString !next tab
		| Types.MCons(Types.NLdbv, next) -> print_string ((tab^"NLdbv "^"\n")); programToString !next tab
		| Types.MCons(Types.BLdbv v, next) -> print_string ((tab^"BLdbv "^(string_of_bool v)^"\n")); programToString !next tab
		| Types.MCons(Types.Ldbf v, next) -> print_string ((tab^"Ldbf "^v^"\n")); programToString !next tab
		| Types.MCons(Types.Ldpos v, next) -> print_string ((tab^"Ldpos "^(string_of_int v)^"\n")); programToString !next tab
		| Types.MCons(Types.Ldsus r, next) -> print_string (tab^"Ldsus\n\tSUS\n"); programToString !r (tab^"\t"); print_string (tab^"\tEND SUS\n"); programToString !next tab
		| Types.MCons(Types.Ldcl r, next) -> print_string (tab^"Ldcl\n\tCLOS\n"); programToString !r (tab^"\t"); print_string (tab^"\tEND CLOS\n"); programToString !next tab
		| Types.MCons(Types.Ifskip r, next) -> print_string (tab^"Ifskip\n\tIFSKIP\n"); programToString !r (tab^"\t"); print_string (tab^"\tEND IFSKIP\n"); programToString !next tab
		| Types.MCons(Types.Goto r, next) -> print_string (tab^"Goto\n\tGOTO\n"); programToString !r (tab^"\t"); print_string "\tEND GOTO\n"; programToString !next tab
		| Types.MCons(Types.Apply, next) -> print_string (tab^"Apply\n"); programToString !next tab
		| Types.MCons(Types.Apply2, next) -> print_string (tab^"Apply2\n"); programToString !next tab
		| Types.MCons(Types.ConsInstr, next) -> print_string "ConsInstr\n"; programToString !next tab
			
	(* FUNZIONE DI VALUTAZIONE *)
	let eval(program, env) =
		let rec eval_aux(s, e, pc, d) = match pc with
			(* END *)
				Types.MCons(Types.End, _) -> (match s with
							(Types.StackRef v):: tail -> (match !v with
										Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
									| Types.StackRef rf -> v:=!rf; eval_aux(s, e, pc, d)
									| _ -> !v
								)
						| x:: tail -> x
						| _ -> raise (Eval_Exception "Errore End"))
			
			(* ILDBV *)
			| Types.MCons(Types.ILdbv v, next_pc) -> eval_aux((Types.Int v):: s, e,!next_pc, d)
			
			(* BLDBV *)
			| Types.MCons(Types.BLdbv v, next_pc) -> eval_aux((Types.Bool v):: s, e,!next_pc, d)
			
			(* NLDBV *)
			| Types.MCons(Types.NLdbv , next_pc) -> eval_aux((Types.StackNull):: s, e,!next_pc, d)
			
			(* LDBF *)
			| Types.MCons(Types.Ldbf f, next_pc) -> eval_aux((Types.Bfun f):: s, e,!next_pc, d)
			
			(* LDSUS *)
			| Types.MCons(Types.Ldsus sus, next_pc) -> (let r = ref (Types.Sus(sus, ref (!e))) in eval_aux((Types.StackRef r):: s, e,!next_pc, d))
			
			(* LDCL *)
			| Types.MCons(Types.Ldcl clos, next_pc) -> eval_aux((Types.Clos(clos, ref (!e))):: s, e,!next_pc, d)

			(* LDPOS *)
			| Types.MCons(Types.Ldpos p, next_pc) -> eval_aux(getVar(e, p):: s, e,!next_pc, d)

			(* APPLY2 *)			
			| Types.MCons(Types.Apply2, next_pc) ->
					(match s with ((Types.Bfun f):: (Types.Int v2):: (Types.Int v1):: tail) -> eval_aux(iEvalBfun2(f, v2, v1):: tail, e,!next_pc, d)
						
						| ((Types.Bfun f):: (Types.Bool v2):: (Types.Bool v1):: tail) -> eval_aux(bEvalBfun2(f, v2, v1):: tail, e,!next_pc, d)
						
						| ((Types.Bfun f):: (Types.StackRef v2):: (Types.Int v1):: tail) ->
								(match !v2 with Types.Int x -> eval_aux(iEvalBfun2(f, x, v1):: tail, e,!next_pc, d)
									| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v2):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
									| Types.StackRef rf -> v2:=!rf; eval_aux(s, e, pc, d)
									| _ -> raise (Eval_Exception "Errore Apply2 StackRef !Int"))
						
						| ((Types.Bfun f):: (Types.StackRef v2):: (Types.Bool v1):: tail) ->
								(match !v2 with Types.Bool x -> eval_aux(bEvalBfun2(f, x, v1):: tail, e,!next_pc, d)
									| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v2):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
									| Types.StackRef rf -> v2:=!rf; eval_aux(s, e, pc, d)
									| _ -> raise (Eval_Exception "Errore Apply2 StackRef !Bool"))
						
						| ((Types.Bfun f):: (Types.Int v2):: (Types.StackRef v1):: tail) ->
								(match !v1 with Types.Int x -> eval_aux(iEvalBfun2(f, v2, x):: tail, e,!next_pc, d)
									| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v1):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
									| Types.StackRef rf -> v1:=!rf; eval_aux(s, e, pc, d)
									| _ -> raise (Eval_Exception "Errore Apply2 !Int StackRef"))
						
						| ((Types.Bfun f):: (Types.Bool v2):: (Types.StackRef v1):: tail) ->
								(match !v1 with Types.Bool x -> eval_aux(bEvalBfun2(f, v2, x):: tail, e,!next_pc, d)
									| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v1):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
									| Types.StackRef rf -> v1:=!rf; eval_aux(s, e, pc, d)
									| _ -> raise (Eval_Exception "Errore Apply2 !Bool StackRef"))
						
						| ((Types.Bfun f):: (Types.StackRef v2):: (Types.StackRef v1):: tail) ->
								(match !v2 with Types.Int x ->
											(match !v1 with Types.Int y -> eval_aux(iEvalBfun2(f, x, y):: tail, e,!next_pc, d)
												| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v1):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
												| Types.StackRef rf -> v1:=!rf; eval_aux(s, e, pc, d)
												| _ -> raise (Eval_Exception "Errore Apply2 StackRef->Int !StackRef->Int"))
									| Types.Bool x ->
											(match !v1 with Types.Bool y -> eval_aux(bEvalBfun2(f, x, y):: tail, e,!next_pc, d)
												| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v1):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
												| Types.StackRef rf -> v1:=!rf; eval_aux(s, e, pc, d)
												| _ -> raise (Eval_Exception "Errore Apply2 StackRef->Bool !StackRef->Bool"))
									
									| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v2):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
									| Types.StackRef rf -> v2:=!rf; eval_aux(s, e, pc, d)
									| _ -> raise (Eval_Exception "Errore Apply2 StackRef StackRef"))
						
						| _ -> raise (Eval_Exception "Errore Apply2"))
			(* FINE APPLY2 *)
			
			(* APPLY *)
			| Types.MCons(Types.Apply, next_pc) ->
					(match s with ((Types.Bfun f):: (Types.Int v):: tail) -> eval_aux(iEvalBfun(f, v):: tail, e,!next_pc, d)
						
						| ((Types.Bfun f):: (Types.Bool v):: tail) -> eval_aux(bEvalBfun(f, v):: tail, e,!next_pc, d)
						
						| ((Types.Bfun f):: ((Types.Cons (e1, e2)) as lista :: tail)) -> eval_aux(lEvalBfun(f, lista):: tail, e,!next_pc, d)
						
						| ((Types.Bfun "isnull"):: (Types.StackNull :: tail)) -> eval_aux((Types.Bool true) :: tail, e,!next_pc, d)

						| ((Types.Bfun "tl"):: (Types.StackNull :: tail)) -> eval_aux(Types.StackNull :: tail, e,!next_pc, d)

						| ((Types.Bfun f):: (Types.StackRef v):: tail) ->
								(match !v with Types.Int x -> eval_aux(iEvalBfun(f, x):: tail, e,!next_pc, d)
									| Types.Bool x -> eval_aux(bEvalBfun(f, x):: tail, e,!next_pc, d)
									| Types.Cons(e1, e2) as lista -> eval_aux(lEvalBfun(f, lista):: tail, e,!next_pc, d)
									| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
									| Types.StackRef rf -> v:=!rf; eval_aux(s, e, pc, d)
									| Types.StackNull when f = "isnull" -> eval_aux((Types.Bool true) :: tail, e,!next_pc, d)
									| Types.StackNull when f = "tl" -> eval_aux(Types.StackNull :: tail, e,!next_pc, d)
									| _ -> raise (Eval_Exception "Errore Apply StackRef"))
						
						| ((Types.Clos(closPc, closEnv)):: v:: tail) ->
								(let r = ref (!closEnv) in addEnv(v, ref r);
									eval_aux(tail, r,!closPc, ref (Types.MCons(((ref (!e),!next_pc), d)))))
						
						| ((Types.StackRef r):: v:: tail) ->
								(match !r with Types.Clos(closPc, closEnv) ->
											(let r = ref (!closEnv) in addEnv(v, ref r);
												eval_aux(tail, r,!closPc, ref (Types.MCons(((ref (!e),!next_pc), d)))))
									| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef r):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
									| Types.StackRef rf -> r:=!rf; eval_aux(s, e, pc, d)
									| _ -> raise (Eval_Exception "Errore Apply StackRef->Closure"))
						| _ -> raise (Eval_Exception "Errore Apply"))
			(* FINE APPLY *)
			
			(* EXIT *)
			| Types.MCons(Types.Exit, next_pc) -> eval_aux(s, (getEnv d), (getPC d), (getDump d))
			
			(* STORE *)
			| Types.MCons(Types.Store, next_pc) ->
					(match s with v:: (Types.StackRef r):: tail -> r := v; eval_aux(tail, (getEnv d), (getPC d), (getDump d))
						| _ -> raise (Eval_Exception "Errore Store"))
			
			(* IFSKIP *)
			| Types.MCons(Types.Ifskip r, next_pc) ->
					(match s with (Types.Bool v):: tail -> if v = true then eval_aux(tail, e,!next_pc, d) else eval_aux(tail, e,!r, d)
						| (Types.StackRef v):: tail ->
								(match !v with Types.Bool b -> if b = true then eval_aux(tail, e,!next_pc, d) else eval_aux(tail, e,!r, d)
									| Types.Sus (sus_pc, sus_e) -> eval_aux((Types.StackRef v):: s, sus_e,!sus_pc, ref (Types.MCons((ref (!e), pc), d)))
									| Types.StackRef rf -> v:=!rf; eval_aux(s, e, pc, d)
									| _ -> raise (Eval_Exception "Errore Ifskip !StackRef->Bool"))
						| _ -> raise (Eval_Exception "Errore Ifskip !Bool"))

			(* GOTO *)
			| Types.MCons(Types.Goto r, next_pc) -> eval_aux(s, e,!r, d)
			
			(* CONSINSTR *)
			| Types.MCons(Types.ConsInstr, next_pc) -> (match s with v1:: v2:: tail -> eval_aux((Types.Cons(v1, v2)):: tail, e,!next_pc, d)
						| _ -> raise (Eval_Exception "Errore ConsInstr"))
			
			| _ -> raise (Eval_Exception "Errore eval_aux") (* FINE EVAL_AUX *)
		
		(*in programToString program "\t";eval_aux([],env,program,ref Types.MNil)*)
		
(* PER STAMPARE IL CODICE COMPILATO DEL PROGRAMMA DECOMMENTARE LA RIGA PRECEDENTE E COMMENTARE QUELLA SUCCESSIVA *)		

		in eval_aux([], env, program, ref Types.MNil)
end;;